Sub AddPrimaryKey()
On Error GoTo PKErrorTrap
Dim cat1 As ADOX.Catalog
Dim tbl1 As ADOX.Table
Dim index1 As ADOX.Index
Dim loopvar As Integer

Set cat1 = New ADOX.Catalog
Set tbl1 = New ADOX.Table
Set index1 = New ADOX.Index

'Specify database engine, data source, and table to index
cat1.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" _
     & "Data Source=C:\LunarSociety\NewDB.mdb"
Set tbl1 = cat1.Tables("Donors")

'Set index properties for primary key
'Label SetIndexVariable provides an entry point after error recovery
SetIndexVariable:
With index1
     .Name = "PKindex"
     .PrimaryKey = True
     .Unique = True
     .IndexNulls = adIndexNullsDisallow
End With

'Append column to index, and specify sort order
index1.Columns.Append "DonorID"
index1.Columns(0).SortOrder = adSortAscending

'Append index to table
tbl1.Indexes.Append index1

'Clean up before exiting
RoutineExit:
Set cat1 = Nothing
Set tbl1 = Nothing
Set index1 = Nothing
Exit Sub

PKErrorTrap:
Select Case Err.Number
'Key addition will fail if table is open
     Case -2147217856
          MsgBox "Table Donors in use. Close and retry."
          Resume RoutineExit
'Key addition will fail if a primary key already exists.
'Delete existing primary key
     Case -2147467259
          For Each index1 In tbl1.Indexes
               If index1.PrimaryKey = True Then
                    tbl1.Indexes.Delete (loopvar)
                    Resume SetIndexVariable
               End If
               loopvar = loopvar + 1
          Next index1
'Key addition will fail if an index already exists for the
'column or columns you are attempting to declare as a
'primary key. Delete existing index, then resume.
     Case -2147217868
          For Each index1 In tbl1.Indexes
               If index1.Name = PKindex Then
                    tbl1.Indexes.Delete (loopvar)
                    Resume SetIndexVariable
               End If
               loopvar = loopvar + 1
          Next index1
'Something else bad has happened
     Case Else
          MsgBox "Open Immediate window for error message"
          Debug.Print Err.Number; Err.Description
End Select
    
End Sub
